home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / YAML / Loader.pm < prev    next >
Encoding:
Perl POD Document  |  2010-01-02  |  23.8 KB  |  791 lines
  1. package YAML::Loader;
  2.  
  3. use strict;
  4. use warnings;
  5. use YAML::Base;
  6. use YAML::Loader::Base;
  7. use YAML::Types;
  8.  
  9. our $VERSION = '0.71';
  10. our @ISA     = 'YAML::Loader::Base';
  11.  
  12. # Context constants
  13. use constant LEAF       => 1;
  14. use constant COLLECTION => 2;
  15. use constant VALUE      => "\x07YAML\x07VALUE\x07";
  16. use constant COMMENT    => "\x07YAML\x07COMMENT\x07";
  17.  
  18. # Common YAML character sets
  19. my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
  20. my $FOLD_CHAR   = '>';
  21. my $LIT_CHAR    = '|';    
  22. my $LIT_CHAR_RX = "\\$LIT_CHAR";    
  23.  
  24. sub load {
  25.     my $self = shift;
  26.     $self->stream($_[0] || '');
  27.     return $self->_parse();
  28. }
  29.  
  30. # Top level function for parsing. Parse each document in order and
  31. # handle processing for YAML headers.
  32. sub _parse {
  33.     my $self = shift;
  34.     my (%directives, $preface);
  35.     $self->{stream} =~ s|\015\012|\012|g;
  36.     $self->{stream} =~ s|\015|\012|g;
  37.     $self->line(0);
  38.     $self->die('YAML_PARSE_ERR_BAD_CHARS') 
  39.       if $self->stream =~ /$ESCAPE_CHAR/;
  40.     $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE') 
  41.       if length($self->stream) and 
  42.          $self->{stream} !~ s/(.)\n\Z/$1/s;
  43.     $self->lines([split /\x0a/, $self->stream, -1]);
  44.     $self->line(1);
  45.     # Throw away any comments or blanks before the header (or start of
  46.     # content for headerless streams)
  47.     $self->_parse_throwaway_comments();
  48.     $self->document(0);
  49.     $self->documents([]);
  50.     # Add an "assumed" header if there is no header and the stream is
  51.     # not empty (after initial throwaways).
  52.     if (not $self->eos) {
  53.         if ($self->lines->[0] !~ /^---(\s|$)/) {
  54.             unshift @{$self->lines}, '---';
  55.             $self->{line}--;
  56.         }
  57.     }
  58.  
  59.     # Main Loop. Parse out all the top level nodes and return them.
  60.     while (not $self->eos) {
  61.         $self->anchor2node({});
  62.         $self->{document}++;
  63.         $self->done(0);
  64.         $self->level(0);
  65.         $self->offset->[0] = -1;
  66.  
  67.         if ($self->lines->[0] =~ /^---\s*(.*)$/) {
  68.             my @words = split /\s+/, $1;
  69.             %directives = ();
  70.             while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
  71.                 my ($key, $value) = ($1, $2);
  72.                 shift(@words);
  73.                 if (defined $directives{$key}) {
  74.                     $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES',
  75.                       $key, $self->document);
  76.                     next;
  77.                 }
  78.                 $directives{$key} = $value;
  79.             }
  80.             $self->preface(join ' ', @words);
  81.         }
  82.         else {
  83.             $self->die('YAML_PARSE_ERR_NO_SEPARATOR');
  84.         }
  85.  
  86.         if (not $self->done) {
  87.             $self->_parse_next_line(COLLECTION);
  88.         }
  89.         if ($self->done) {
  90.             $self->{indent} = -1;
  91.             $self->content('');
  92.         }
  93.  
  94.         $directives{YAML} ||= '1.0';
  95.         $directives{TAB} ||= 'NONE';
  96.         ($self->{major_version}, $self->{minor_version}) = 
  97.           split /\./, $directives{YAML}, 2;
  98.         $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
  99.           if $self->major_version ne '1';
  100.         $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML})
  101.           if $self->minor_version ne '0';
  102.         $self->die('Unrecognized TAB policy')
  103.           unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
  104.  
  105.         push @{$self->documents}, $self->_parse_node();
  106.     }
  107.     return wantarray ? @{$self->documents} : $self->documents->[-1];
  108. }
  109.  
  110. # This function is the dispatcher for parsing each node. Every node
  111. # recurses back through here. (Inlines are an exception as they have
  112. # their own sub-parser.)
  113. sub _parse_node {
  114.     my $self = shift;
  115.     my $preface = $self->preface;
  116.     $self->preface('');
  117.     my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
  118.     my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
  119.     ($anchor, $alias, $explicit, $implicit, $preface) = 
  120.       $self->_parse_qualifiers($preface);
  121.     if ($anchor) {
  122.         $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
  123.     }
  124.     $self->inline('');
  125.     while (length $preface) {
  126.         my $line = $self->line - 1;
  127.         if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) { 
  128.             $indicator = $1;
  129.             $chomp = $2 if defined($2);
  130.         }
  131.         else {
  132.             $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator;
  133.             $self->inline($preface);
  134.             $preface = '';
  135.         }
  136.     }
  137.     if ($alias) {
  138.         $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
  139.           unless defined $self->anchor2node->{$alias};
  140.         if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
  141.             $node = $self->anchor2node->{$alias};
  142.         }
  143.         else {
  144.             $node = do {my $sv = "*$alias"};
  145.             push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; 
  146.         }
  147.     }
  148.     elsif (length $self->inline) {
  149.         $node = $self->_parse_inline(1, $implicit, $explicit);
  150.         if (length $self->inline) {
  151.             $self->die('YAML_PARSE_ERR_SINGLE_LINE'); 
  152.         }
  153.     }
  154.     elsif ($indicator eq $LIT_CHAR) {
  155.         $self->{level}++;
  156.         $node = $self->_parse_block($chomp);
  157.         $node = $self->_parse_implicit($node) if $implicit;
  158.         $self->{level}--; 
  159.     }
  160.     elsif ($indicator eq $FOLD_CHAR) {
  161.         $self->{level}++;
  162.         $node = $self->_parse_unfold($chomp);
  163.         $node = $self->_parse_implicit($node) if $implicit;
  164.         $self->{level}--;
  165.     }
  166.     else {
  167.         $self->{level}++;
  168.         $self->offset->[$self->level] ||= 0;
  169.         if ($self->indent == $self->offset->[$self->level]) {
  170.             if ($self->content =~ /^-( |$)/) {
  171.                 $node = $self->_parse_seq($anchor);
  172.             }
  173.             elsif ($self->content =~ /(^\?|\:( |$))/) {
  174.                 $node = $self->_parse_mapping($anchor);
  175.             }
  176.             elsif ($preface =~ /^\s*$/) {
  177.                 $node = $self->_parse_implicit('');
  178.             }
  179.             else {
  180.                 $self->die('YAML_PARSE_ERR_BAD_NODE');
  181.             }
  182.         }
  183.         else {
  184.             $node = undef;
  185.         }
  186.         $self->{level}--;
  187.     }
  188.     $#{$self->offset} = $self->level;
  189.  
  190.     if ($explicit) {
  191.         if ($class) {
  192.             if (not ref $node) {
  193.                 my $copy = $node;
  194.                 undef $node;
  195.                 $node = \$copy;
  196.             }
  197.             CORE::bless $node, $class;
  198.         }
  199.         else {
  200.             $node = $self->_parse_explicit($node, $explicit);
  201.         }
  202.     }
  203.     if ($anchor) {
  204.         if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
  205.             # XXX Can't remember what this code actually does
  206.             for my $ref (@{$self->anchor2node->{$anchor}}) {
  207.                 ${$ref->[0]} = $node;
  208.                 $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
  209.                     $anchor, $ref->[1]);
  210.             }
  211.         }
  212.         $self->anchor2node->{$anchor} = $node;
  213.     }
  214.     return $node;
  215. }
  216.  
  217. # Preprocess the qualifiers that may be attached to any node.
  218. sub _parse_qualifiers {
  219.     my $self = shift;
  220.     my ($preface) = @_;
  221.     my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5;
  222.     $self->inline('');
  223.     while ($preface =~ /^[&*!]/) {
  224.         my $line = $self->line - 1;
  225.         if ($preface =~ s/^\!(\S+)\s*//) {
  226.             $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit;
  227.             $explicit = $1;
  228.         }
  229.         elsif ($preface =~ s/^\!\s*//) {
  230.             $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit;
  231.             $implicit = 1;
  232.         }
  233.         elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
  234.             $token = $1;
  235.             $self->die('YAML_PARSE_ERR_BAD_ANCHOR') 
  236.               unless $token =~ /^[a-zA-Z0-9]+$/;
  237.             $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
  238.             $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
  239.             $anchor = $token;
  240.         }
  241.         elsif ($preface =~ s/^\*([^ ,:]+)\s*//) {
  242.             $token = $1;
  243.             $self->die('YAML_PARSE_ERR_BAD_ALIAS')
  244.               unless $token =~ /^[a-zA-Z0-9]+$/;
  245.             $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias;
  246.             $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor;
  247.             $alias = $token;
  248.         }
  249.     }
  250.     return ($anchor, $alias, $explicit, $implicit, $preface); 
  251. }
  252.  
  253. # Morph a node to it's explicit type  
  254. sub _parse_explicit {
  255.     my $self = shift;
  256.     my ($node, $explicit) = @_;
  257.     my ($type, $class);
  258.     if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
  259.         ($type, $class) = (($1 || ''), ($2 || ''));
  260.  
  261.         # FIXME # die unless uc($type) eq ref($node) ?
  262.  
  263.         if ( $type eq "ref" ) {
  264.             $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
  265.             unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
  266.  
  267.             my $value = $node->{VALUE()};
  268.             $node = \$value;
  269.         }
  270.         
  271.         if ( $type eq "scalar" and length($class) and !ref($node) ) {
  272.             my $value = $node;
  273.             $node = \$value;
  274.         }
  275.  
  276.         if ( length($class) ) {
  277.             CORE::bless($node, $class);
  278.         }
  279.  
  280.         return $node;
  281.     }
  282.     if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
  283.         ($type, $class) = (($1 || ''), ($2 || ''));
  284.         my $type_class = "YAML::Type::$type";
  285.         no strict 'refs';
  286.         if ($type_class->can('yaml_load')) {
  287.             return $type_class->yaml_load($node, $class, $self);
  288.         }
  289.         else {
  290.             $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit);
  291.         }
  292.     }
  293.     # This !perl/@Foo and !perl/$Foo are deprecated but still parsed
  294.     elsif ($YAML::TagClass->{$explicit} ||
  295.            $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}
  296.           ) {
  297.         $class = $YAML::TagClass->{$explicit} || $2;
  298.         if ($class->can('yaml_load')) {
  299.             require YAML::Node;
  300.             return $class->yaml_load(YAML::Node->new($node, $explicit));
  301.         }
  302.         else {
  303.             if (ref $node) {
  304.                 return CORE::bless $node, $class;
  305.             }
  306.             else {
  307.                 return CORE::bless \$node, $class;
  308.             }
  309.         }
  310.     }
  311.     elsif (ref $node) {
  312.         require YAML::Node;
  313.         return YAML::Node->new($node, $explicit);
  314.     }
  315.     else {
  316.         # XXX This is likely wrong. Failing test:
  317.         # --- !unknown 'scalar value'
  318.         return $node;
  319.     }
  320. }
  321.  
  322. # Parse a YAML mapping into a Perl hash
  323. sub _parse_mapping {
  324.     my $self = shift;
  325.     my ($anchor) = @_;
  326.     my $mapping = {};
  327.     $self->anchor2node->{$anchor} = $mapping;
  328.     my $key;
  329.     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
  330.         # If structured key:
  331.         if ($self->{content} =~ s/^\?\s*//) {
  332.             $self->preface($self->content);
  333.             $self->_parse_next_line(COLLECTION);
  334.             $key = $self->_parse_node();
  335.             $key = "$key";
  336.         }
  337.         # If "default" key (equals sign) 
  338.         elsif ($self->{content} =~ s/^\=\s*//) {
  339.             $key = VALUE;
  340.         }
  341.         # If "comment" key (slash slash)
  342.         elsif ($self->{content} =~ s/^\=\s*//) {
  343.             $key = COMMENT;
  344.         }
  345.         # Regular scalar key:
  346.         else {
  347.             $self->inline($self->content);
  348.             $key = $self->_parse_inline();
  349.             $key = "$key";
  350.             $self->content($self->inline);
  351.             $self->inline('');
  352.         }
  353.             
  354.         unless ($self->{content} =~ s/^:\s*//) {
  355.             $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
  356.         }
  357.         $self->preface($self->content);
  358.         my $line = $self->line;
  359.         $self->_parse_next_line(COLLECTION);
  360.         my $value = $self->_parse_node();
  361.         if (exists $mapping->{$key}) {
  362.             $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
  363.         }
  364.         else {
  365.             $mapping->{$key} = $value;
  366.         }
  367.     }
  368.     return $mapping;
  369. }
  370.  
  371. # Parse a YAML sequence into a Perl array
  372. sub _parse_seq {
  373.     my $self = shift;
  374.     my ($anchor) = @_;
  375.     my $seq = [];
  376.     $self->anchor2node->{$anchor} = $seq;
  377.     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
  378.         if ($self->content =~ /^-(?: (.*))?$/) {
  379.             $self->preface(defined($1) ? $1 : '');
  380.         }
  381.         else {
  382.             $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT');
  383.         }
  384.         if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) {
  385.             $self->indent($self->offset->[$self->level] + 2 + length($1));
  386.             $self->content($2);
  387.             $self->level($self->level + 1);
  388.             $self->offset->[$self->level] = $self->indent;
  389.             $self->preface('');
  390.             push @$seq, $self->_parse_mapping('');
  391.             $self->{level}--;
  392.             $#{$self->offset} = $self->level;
  393.         }
  394.         else {
  395.             $self->_parse_next_line(COLLECTION);
  396.             push @$seq, $self->_parse_node();
  397.         }
  398.     }
  399.     return $seq;
  400. }
  401.  
  402. # Parse an inline value. Since YAML supports inline collections, this is
  403. # the top level of a sub parsing.
  404. sub _parse_inline {
  405.     my $self = shift;
  406.     my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
  407.     $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
  408.     my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
  409.     ($anchor, $alias, $explicit, $implicit, $self->{inline}) = 
  410.       $self->_parse_qualifiers($self->inline);
  411.     if ($anchor) {
  412.         $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
  413.     }
  414.     $implicit ||= $top_implicit;
  415.     $explicit ||= $top_explicit;
  416.     ($top_implicit, $top_explicit) = ('', '');
  417.     if ($alias) {
  418.         $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
  419.           unless defined $self->anchor2node->{$alias};
  420.         if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
  421.             $node = $self->anchor2node->{$alias};
  422.         }
  423.         else {
  424.             $node = do {my $sv = "*$alias"};
  425.             push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; 
  426.         }
  427.     }
  428.     elsif ($self->inline =~ /^\{/) {
  429.         $node = $self->_parse_inline_mapping($anchor);
  430.     }
  431.     elsif ($self->inline =~ /^\[/) {
  432.         $node = $self->_parse_inline_seq($anchor);
  433.     }
  434.     elsif ($self->inline =~ /^"/) {
  435.         $node = $self->_parse_inline_double_quoted();
  436.         $node = $self->_unescape($node);
  437.         $node = $self->_parse_implicit($node) if $implicit;
  438.     }
  439.     elsif ($self->inline =~ /^'/) {
  440.         $node = $self->_parse_inline_single_quoted();
  441.         $node = $self->_parse_implicit($node) if $implicit;
  442.     }
  443.     else {
  444.         if ($top) {
  445.             $node = $self->inline;
  446.             $self->inline('');
  447.         }
  448.         else {
  449.             $node = $self->_parse_inline_simple();
  450.         }
  451.         $node = $self->_parse_implicit($node) unless $explicit;
  452.     }
  453.     if ($explicit) {
  454.         $node = $self->_parse_explicit($node, $explicit);
  455.     }
  456.     if ($anchor) {
  457.         if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
  458.             for my $ref (@{$self->anchor2node->{$anchor}}) {
  459.                 ${$ref->[0]} = $node;
  460.                 $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
  461.                     $anchor, $ref->[1]);
  462.             }
  463.         }
  464.         $self->anchor2node->{$anchor} = $node;
  465.     }
  466.     return $node;
  467. }
  468.  
  469. # Parse the inline YAML mapping into a Perl hash
  470. sub _parse_inline_mapping {
  471.     my $self = shift;
  472.     my ($anchor) = @_;
  473.     my $node = {};
  474.     $self->anchor2node->{$anchor} = $node;
  475.  
  476.     $self->die('YAML_PARSE_ERR_INLINE_MAP')
  477.       unless $self->{inline} =~ s/^\{\s*//;
  478.     while (not $self->{inline} =~ s/^\s*\}//) {
  479.         my $key = $self->_parse_inline();
  480.         $self->die('YAML_PARSE_ERR_INLINE_MAP')
  481.           unless $self->{inline} =~ s/^\: \s*//;
  482.         my $value = $self->_parse_inline();
  483.         if (exists $node->{$key}) {
  484.             $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
  485.         }
  486.         else {
  487.             $node->{$key} = $value;
  488.         }
  489.         next if $self->inline =~ /^\s*\}/;
  490.         $self->die('YAML_PARSE_ERR_INLINE_MAP')
  491.           unless $self->{inline} =~ s/^\,\s*//;
  492.     }
  493.     return $node;
  494. }
  495.  
  496. # Parse the inline YAML sequence into a Perl array
  497. sub _parse_inline_seq {
  498.     my $self = shift;
  499.     my ($anchor) = @_;
  500.     my $node = [];
  501.     $self->anchor2node->{$anchor} = $node;
  502.  
  503.     $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
  504.       unless $self->{inline} =~ s/^\[\s*//;
  505.     while (not $self->{inline} =~ s/^\s*\]//) {
  506.         my $value = $self->_parse_inline();
  507.         push @$node, $value;
  508.         next if $self->inline =~ /^\s*\]/;
  509.         $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') 
  510.           unless $self->{inline} =~ s/^\,\s*//;
  511.     }
  512.     return $node;
  513. }
  514.  
  515. # Parse the inline double quoted string.
  516. sub _parse_inline_double_quoted {
  517.     my $self = shift;
  518.     my $node;
  519.     if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
  520.         $node = $1;
  521.         $self->inline($2);
  522.         $node =~ s/\\"/"/g;
  523.     }
  524.     else {
  525.         $self->die('YAML_PARSE_ERR_BAD_DOUBLE');
  526.     }
  527.     return $node;
  528. }
  529.  
  530.  
  531. # Parse the inline single quoted string.
  532. sub _parse_inline_single_quoted {
  533.     my $self = shift;
  534.     my $node;
  535.     if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
  536.         $node = $1;
  537.         $self->inline($2);
  538.         $node =~ s/''/'/g;
  539.     }
  540.     else {
  541.         $self->die('YAML_PARSE_ERR_BAD_SINGLE');
  542.     }
  543.     return $node;
  544. }
  545.  
  546. # Parse the inline unquoted string and do implicit typing.
  547. sub _parse_inline_simple {
  548.     my $self = shift;
  549.     my $value;
  550.     if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) {
  551.         $value = $1;
  552.         substr($self->{inline}, 0, length($1)) = '';
  553.     }
  554.     else {
  555.         $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value);
  556.     }
  557.     return $value;
  558. }
  559.  
  560. sub _parse_implicit {
  561.     my $self = shift;
  562.     my ($value) = @_;
  563.     $value =~ s/\s*$//;
  564.     return $value if $value eq '';
  565.     return undef if $value =~ /^~$/;
  566.     return $value
  567.       unless $value =~ /^[\@\`\^]/ or
  568.              $value =~ /^[\-\?]\s/;
  569.     $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
  570. }
  571.  
  572. # Unfold a YAML multiline scalar into a single string.
  573. sub _parse_unfold {
  574.     my $self = shift;
  575.     my ($chomp) = @_;
  576.     my $node = '';
  577.     my $space = 0;
  578.     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
  579.         $node .= $self->content. "\n";
  580.         $self->_parse_next_line(LEAF);
  581.     }
  582.     $node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
  583.     $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
  584.     $node =~ s/\n*\Z// unless $chomp eq '+';
  585.     $node .= "\n" unless $chomp;
  586.     return $node;
  587. }
  588.  
  589. # Parse a YAML block style scalar. This is like a Perl here-document.
  590. sub _parse_block {
  591.     my $self = shift;
  592.     my ($chomp) = @_;
  593.     my $node = '';
  594.     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
  595.         $node .= $self->content . "\n";
  596.         $self->_parse_next_line(LEAF);
  597.     }
  598.     return $node if '+' eq $chomp;
  599.     $node =~ s/\n*\Z/\n/;
  600.     $node =~ s/\n\Z// if $chomp eq '-';
  601.     return $node;
  602. }
  603.  
  604. # Handle Perl style '#' comments. Comments must be at the same indentation
  605. # level as the collection line following them.
  606. sub _parse_throwaway_comments {
  607.     my $self = shift;
  608.     while (@{$self->lines} and
  609.            $self->lines->[0] =~ m{^\s*(\#|$)}
  610.           ) {
  611.         shift @{$self->lines};
  612.         $self->{line}++;
  613.     }
  614.     $self->eos($self->{done} = not @{$self->lines});
  615. }
  616.  
  617. # This is the routine that controls what line is being parsed. It gets called
  618. # once for each line in the YAML stream.
  619. #
  620. # This routine must:
  621. # 1) Skip past the current line
  622. # 2) Determine the indentation offset for a new level
  623. # 3) Find the next _content_ line
  624. #   A) Skip over any throwaways (Comments/blanks)
  625. #   B) Set $self->indent, $self->content, $self->line
  626. # 4) Expand tabs appropriately  
  627. sub _parse_next_line {
  628.     my $self = shift;
  629.     my ($type) = @_;
  630.     my $level = $self->level;
  631.     my $offset = $self->offset->[$level];
  632.     $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset;
  633.     shift @{$self->lines};
  634.     $self->eos($self->{done} = not @{$self->lines});
  635.     return if $self->eos;
  636.     $self->{line}++;
  637.  
  638.     # Determine the offset for a new leaf node
  639.     if ($self->preface =~
  640.         qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/
  641.        ) {
  642.         $self->die('YAML_PARSE_ERR_ZERO_INDENT')
  643.           if length($1) and $1 == 0;
  644.         $type = LEAF;
  645.         if (length($1)) {
  646.             $self->offset->[$level + 1] = $offset + $1;
  647.         }
  648.         else {
  649.             # First get rid of any comments.
  650.             while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
  651.                 $self->lines->[0] =~ /^( *)/ or die;
  652.                 last unless length($1) <= $offset;
  653.                 shift @{$self->lines};
  654.                 $self->{line}++;
  655.             }
  656.             $self->eos($self->{done} = not @{$self->lines});
  657.             return if $self->eos;
  658.             if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) {
  659.                 $self->offset->[$level+1] = length($1);
  660.             }
  661.             else {
  662.                 $self->offset->[$level+1] = $offset + 1;
  663.             }
  664.         }
  665.         $offset = $self->offset->[++$level];
  666.     }
  667.     # Determine the offset for a new collection level
  668.     elsif ($type == COLLECTION and 
  669.            $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
  670.         $self->_parse_throwaway_comments();
  671.         if ($self->eos) {
  672.             $self->offset->[$level+1] = $offset + 1;
  673.             return;
  674.         }
  675.         else {
  676.             $self->lines->[0] =~ /^( *)\S/ or die;
  677.             if (length($1) > $offset) {
  678.                 $self->offset->[$level+1] = length($1);
  679.             }
  680.             else {
  681.                 $self->offset->[$level+1] = $offset + 1;
  682.             }
  683.         }
  684.         $offset = $self->offset->[++$level];
  685.     }
  686.         
  687.     if ($type == LEAF) {
  688.         while (@{$self->lines} and
  689.                $self->lines->[0] =~ m{^( *)(\#)} and
  690.                length($1) < $offset
  691.               ) {
  692.             shift @{$self->lines};
  693.             $self->{line}++;
  694.         }
  695.         $self->eos($self->{done} = not @{$self->lines});
  696.     }
  697.     else {
  698.         $self->_parse_throwaway_comments();
  699.     }
  700.     return if $self->eos; 
  701.     
  702.     if ($self->lines->[0] =~ /^---(\s|$)/) {
  703.         $self->done(1);
  704.         return;
  705.     }
  706.     if ($type == LEAF and 
  707.         $self->lines->[0] =~ /^ {$offset}(.*)$/
  708.        ) {
  709.         $self->indent($offset);
  710.         $self->content($1);
  711.     }
  712.     elsif ($self->lines->[0] =~ /^\s*$/) {
  713.         $self->indent($offset);
  714.         $self->content('');
  715.     }
  716.     else {
  717.         $self->lines->[0] =~ /^( *)(\S.*)$/;
  718.         while ($self->offset->[$level] > length($1)) {
  719.             $level--;
  720.         }
  721.         $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION') 
  722.           if $self->offset->[$level] != length($1);
  723.         $self->indent(length($1));
  724.         $self->content($2);
  725.     }
  726.     $self->die('YAML_PARSE_ERR_INDENTATION')
  727.       if $self->indent - $offset > 1;
  728. }
  729.  
  730. #==============================================================================
  731. # Utility subroutines.
  732. #==============================================================================
  733.  
  734. # Printable characters for escapes
  735. my %unescapes = (
  736.    0 => "\x00",
  737.    a => "\x07",
  738.    t => "\x09",
  739.    n => "\x0a",
  740.    'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted
  741.    f => "\x0c",
  742.    r => "\x0d",
  743.    e => "\x1b",
  744.    '\\' => '\\',
  745.   );
  746.    
  747. # Transform all the backslash style escape characters to their literal meaning
  748. sub _unescape {
  749.     my $self = shift;
  750.     my ($node) = @_;
  751.     $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
  752.               (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
  753.     return $node;
  754. }
  755.  
  756. 1;
  757.  
  758. __END__
  759.  
  760. =head1 NAME
  761.  
  762. YAML::Loader - YAML class for loading Perl objects to YAML
  763.  
  764. =head1 SYNOPSIS
  765.  
  766.     use YAML::Loader;
  767.     my $loader = YAML::Loader->new;
  768.     my $hash = $loader->load(<<'...');
  769.     foo: bar
  770.     ...
  771.  
  772. =head1 DESCRIPTION
  773.  
  774. YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl
  775. objects. It is fully object oriented and usable on its own.
  776.  
  777. =head1 AUTHOR
  778.  
  779. Ingy d├╢t Net <ingy@cpan.org>
  780.  
  781. =head1 COPYRIGHT
  782.  
  783. Copyright (c) 2006. Ingy d├╢t Net. All rights reserved.
  784.  
  785. This program is free software; you can redistribute it and/or modify it
  786. under the same terms as Perl itself.
  787.  
  788. See L<http://www.perl.com/perl/misc/Artistic.html>
  789.  
  790. =cut
  791.